home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 326-350 / disk_339 / pcq / examples / whichfont.p < prev    next >
Text File  |  1992-05-06  |  8KB  |  250 lines
  1. Program WhichFont;
  2.  
  3. {
  4.  sample program that asks AvailFonts() to make a list of the fonts
  5.  that are available and makes a list of them, then opens a separate
  6.  window and prints a description of the various attributes that can
  7.  be applied to the fonts, in the font itself.  Notice that not all
  8.  fonts accept all attributes (garnet9 for example, won't underline)
  9.  
  10.  Also note, if you run this, that not all fonts are as easily readable
  11.  in the various bold and italicized modes.... this rendering is done
  12.  in a fixed manner by software and the fonts were not necessarily
  13.  designed to accept it.  It is always best to have a font that has
  14.  been designed with a bold or italic characteristic built-in rather
  15.  than try to bold-ize or italicize and existing plain font.
  16. }
  17.  
  18. { Author:  Rob Peck  10/28/85  }
  19. { Converted to PCQ Pascal 2/7/90.  For how little it does, this
  20.   program sure does use a lot of include files... }
  21.  
  22. {$I ":Include/Ports.i"}
  23. {$I ":Include/Graphics.i"}
  24. {$I ":Include/Text.i"}
  25. {$I ":Include/Exec.i"}
  26. {$I ":Include/DiskFont.i"}
  27. {$I ":Include/Intuition.i"}
  28. {$I ":Include/DOS.i"}
  29. {$I ":Include/StringLib.i"}
  30.  
  31. Const
  32.     AFTABLESIZE = 2000;
  33.  
  34. Var
  35.     af  : AvailFontPtr;
  36.     afh : AvailFontsHeaderPtr;
  37.  
  38.     tf  : TextFontPtr;
  39.     ta  : TextAttr;
  40.  
  41. Const
  42.     nw : NewWindow = (
  43.     10, 10,        { starting position (left,top) }
  44.     620,40,        { width, height }
  45.     -1,-1,          { detailpen, blockpen }
  46.     CLOSEWINDOW_f,  { flags for idcmp }
  47.     WINDOWCLOSE_f + WINDOWDEPTH_f + WINDOWSIZING_f + WINDOWDRAG_f +
  48.     SIMPLE_REFRESH_f + ACTIVATE_f + GIMMEZEROZERO_f,
  49.             { window gadget flags }
  50.     Nil,              { pointer to 1st user gadget }
  51.     Nil,           { pointer to user check }
  52.     "Text Font Test", { title }
  53.     Nil,           { pointer to window screen }
  54.     Nil,           { pointer to super bitmap }
  55.     100,45,         { min width, height }
  56.     640,200,        { max width, height }
  57.     WBENCHSCREEN_f);
  58.  
  59. Var
  60.     w  : WindowPtr;
  61.     rp : RastPortPtr;
  62.  
  63. Const
  64.     text_styles : Array [0..6] of Short = (
  65.     FS_NORMAL, FSF_UNDERLINED, FSF_ITALIC, FSF_BOLD, 
  66.     FSF_ITALIC + FSF_BOLD, FSF_BOLD + FSF_UNDERLINED,
  67.     FSF_ITALIC + FSF_BOLD + FSF_UNDERLINED);
  68.  
  69.      text_desc : Array [0..6] of String = (
  70.     " Normal Text", " Underlined", " Italicized", " Bold", 
  71.     " Bold Italics", " Bold Underlined", 
  72.     " Bold Italic Underlined");
  73.  
  74.     text_length : Array [0..6] of Short = (12, 11, 11, 5, 13, 16, 23);
  75.  
  76.     pointsize  : Array [0..31] of String = (
  77.     " 0"," 1"," 2"," 3"," 4"," 5"," 6"," 7"," 8"," 9",
  78.     "10","11","12","13","14","15","16","17","18","19",
  79.     "20","21","22","23","24","25","26","27","28","29",
  80.     "30","31");
  81.  
  82. Var
  83.     fontname    : Array [0..40] of Char;
  84.     dummy    : Array [0..100] of Char; { provided for string length calculation }
  85.     outst    : Array [0..100] of Char;
  86.             { build something to give to Text, see note in 
  87.                          the program body about algorithmically
  88.                          generated styles 
  89.                          }
  90.  
  91. var
  92.     fonttypes    : Byte;
  93.     i,j,k,m    : Integer;
  94.     afsize    : Short;
  95.     style    : Short;
  96.     sEnd    : Short; { Numerical position of end of string terminator }
  97.     styleresult : Short;
  98.  
  99. Procedure Leave(r : Integer);
  100. begin
  101.     Exit(20);
  102. end;
  103.  
  104. Function IsCopy(af : AvailFontPtr) : Boolean;
  105. begin
  106.     IsCopy :=     (((af^.af_Attr.taFlags and FPF_REMOVED) <> 0) or
  107.         ((af^.af_Attr.taFlags and FPF_REVPATH) <> 0) or
  108.         (((af^.af_Type and AFF_MEMORY) <> 0) and
  109.         ((af^.af_Attr.taFlags and FPF_DISKFONT) <> 0)));
  110.  
  111.        { do nothing if font is removed, or if
  112.      font designed to be rendered rt->left
  113.      (simple example writes left to right)
  114.      or if font both on disk and in ram, 
  115.      don't list it twice. }
  116.  
  117.        { AvailFonts performs an AddFont to the system list;
  118.      if run twice, you get two entries, one of "af_Type 1" saying
  119.      that the font is memory resident, and the other of "af_Type 2"
  120.      saying the font is disk-based.  The third part of the 
  121.      if-statement lets you tell them apart if you are scanning
  122.      the list for unique elements;  it says "if its in memory and
  123.      it is from disk, then don't list it because you'll find another
  124.      entry in the table that says it is not in memory, but is on disk.
  125.      (Another task might have been using the font as well, creating
  126.      the same effect).
  127.     }
  128. end;
  129.  
  130. Begin
  131.     DiskFontBase := OpenLibrary("diskfont.library",0);
  132.     if DiskFontBase = Nil then
  133.     leave(-4);
  134.     GfxBase := OpenLibrary("graphics.library",0);
  135.     if GfxBase = Nil then
  136.     leave(-3);
  137.  
  138.     tf := Nil;        { no font currently selected }
  139.     afsize := AFTABLESIZE;   { show how large a buffer is available }
  140.     fonttypes := $ff;       { show us all font types }
  141.  
  142.     w := OpenWindow(Adr(nw));
  143.     if w <> nil then begin
  144.     rp := w^.RPort;
  145.  
  146.     afh := AvailFontsHeaderPtr(AllocString(afsize));
  147.  
  148.     Move(rp, 10, 20);
  149.     GText(rp, "Searching for fonts",19);
  150.     j := AvailFonts(afh, afsize, fonttypes);
  151.  
  152.     for m := 0 to 1 do begin
  153.         SetAPen(rp,1);
  154.  
  155.         if m = 0 then
  156.         SetDrMd(rp,JAM1)
  157.         else
  158.         SetDrMd(rp,JAM1+INVERSEVID);
  159.  
  160.         { now print a line that says what font and what style it is }
  161.  
  162.         for j := 0 to Pred(afh^.afh_NumEntries) do begin
  163.         af := Adr(afh^.afh_AF[j]);
  164.         strcpy(String(Adr(FontName)), af^.af_Attr.taName);
  165.                         { copy name into build-name area }
  166.                         { already has ".font" onto end of it }
  167.         ta.taName := String(Adr(fontname));
  168.         ta.taYSize := af^.af_Attr.taYSize;     { ask for this size }
  169.         ta.taStyle := af^.af_Attr.taStyle;     { ask for designed style }
  170.         ta.taFlags := FPF_ROMFONT + FPF_DISKFONT +
  171.                 FPF_PROPORTIONAL + FPF_DESIGNED;
  172.                 { accept it from anywhere it exists }
  173.         style := ta.taStyle;
  174.  
  175.         if not IsCopy(af) then begin
  176.             tf := OpenDiskFont(Adr(ta));
  177.             if tf <> Nil then begin
  178.             SetFont(rp, tf);
  179.             for k := 0 to 6 do begin
  180.                 style := text_styles[k];
  181.                 styleresult := SetSoftStyle(rp,style,255);
  182.                 SetRast(rp,0);   { erase any previous text }
  183.                 Move(rp,10,20);  { move down a bit from the top }
  184.                 strcpy(Adr(outst), af^.af_Attr.taName);
  185.                 strcat(Adr(outst), "  ");
  186.                 strcat(Adr(outst), PointSize[af^.af_Attr.taYSize]);
  187.                 strcat(Adr(outst), " Points, ");
  188.                 strcat(Adr(outst), text_desc[k]);
  189.                 GText(rp,Adr(outst),strlen(Adr(outst)));
  190.     {
  191.     Have to build the string before sending it out to
  192.     text IF ALGORITHMICALLY GENERATING THE STYLE since 
  193.     the kerning and spacing tables are based on the
  194.     vanilla text, and not the algorithmically generated
  195.     style.  If you send characters out individually,
  196.     it is possible that the enclosing rectangle of
  197.     a later character will chop off the trailing edge
  198.     of a preceding character 
  199.     }
  200.  
  201.     { ************************************************** 
  202.       This alternate method, when in INVERSVID, exhibits the
  203.       problem described above.
  204.  
  205.             GText(rp,af^.af_Attr.taName,strlen(af^.af_Attr.taName));
  206.             GText(rp,"  ",2);
  207.             GText(rp,pointsize[af^.af_Attr.taYSize],2);
  208.             GText(rp," Points, ",9);
  209.         
  210.             GText(rp,text_desc[k],text_length[k]);
  211.       **************************************************  } 
  212.  
  213.                 Delay(40);  { use the DOS time delay function 
  214.                       specifies 60ths of a second }
  215.                 if GetMsg(w^.UserPort) <> Nil then begin
  216.                 CloseFont(tf);
  217.                 Forbid;
  218.                 repeat until GetMsg(w^.UserPort) = Nil;
  219.                 CloseWindow(w);
  220.                 Permit;
  221.                 CloseLibrary(DiskfontBase);   
  222.                 CloseLibrary(GfxBase);
  223.                 exit(0);
  224.                 end;
  225.             end;
  226.             CloseFont(tf); { close the old one }
  227.  
  228.        { NOTE: 
  229.             Even though you close a font, it doesn't get unloaded
  230.             Memory unless a font with a different name is specified
  231.             for loading.  In this case, any font (except the topaz
  232.             set) which has been closed can have its memory area
  233.             freed and it will no longer be accessible.  If you close
  234.             a font to go to a different point-size, it will NOT cause
  235.             a disk-access.  
  236.        
  237.          ALSO NOTE:   
  238.              Loading a font loads ALL of the point
  239.              sizes contained in that font's directory!!!!
  240.         }
  241.             end;
  242.         end;
  243.         end;
  244.     end;
  245.     CloseWindow(w);
  246.     end;
  247.     CloseLibrary(DiskfontBase);   
  248.     CloseLibrary(GfxBase);
  249. end.
  250.